home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
011a
/
pscrn43.zip
/
EMPLOYEE.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-08-28
|
18KB
|
387 lines
'******************************************************************************
'* File: Employee.Bas
'*
'* Purpose: - 1 of 2 QuickBASIC demo programs written entirely by
'* P-Screen Professional (PS Pro)
'* - Demonstrates several subroutines included in PS Pro:
'* 1. rsMinput 2. rsQprint 3. FormatUsing
'* 4. Exist 5. ProperName 6. rsCmpRst
'*
'* Compatibility: QuickBASIC 4.0 or higher -OR- PDS 7 !!
'* *
'* To run this: qb employee /l ps-demo.qlb -OR- qbx employee /l bc7-demo
'*
'* Notes: - Please read Routines.Doc for details on the subroutines
'* included with PS Pro. These routines are in ps-demo.qlb.
'* - After PS Pro wrote this, we did some minor editing:
'* -- added this intro
'* -- "hardcoded" some variables, taking them out of a loop
'*
'******************************************************************************
'******************************************************************************
'Employee.Bas, written by P-Screen Professional Date: 10-06-1989
'NOTE: Run with QB 4.0+ -OR- PDS7 with these files in your Quick Library:
'LoadScrn, rsLoadBin, rsMinput, rsQprint, Exists, PropName & FmtUsing
'Library = P-Screen Screen Name = Employee # of Fields: 18
'******************************************************************************
DEFINT A-Z 'default = Integers
CONST True = -1, False = NOT True
'----Declare subs. MUST declare QB functions.
DECLARE SUB rsMInput (Text$, ValidKeys$, Exit$, Format$, Length, RetCode, Hilite, Colr)
DECLARE SUB rsQprint (Row, Column, Colr, Text$)
DECLARE SUB rsLoadScrn (Array%(), LibName$, FileName$, Desc$, TopRow, TopCol, BotRow, BotCol, ScrnSize, ErrCode)
DECLARE SUB rsCompRest (TopRow, BotRow, SEG Array)
DECLARE SUB CompRestPlus (TopRow, TopCol, BotRow, BotCol, SEG Array)
DECLARE FUNCTION FormatUsing$ (Format$, x#) 'format numbers for editing
DECLARE FUNCTION Exists (FileName$) 'Exists = -1 if file DOES exist, 0 if it does NOT"
DECLARE FUNCTION ProperName$ (Text$) 'convert lower case text to proper
'******************************************************************************
TYPE TypeX 'define record elements
TodaysDate AS STRING * 16
Name1 AS STRING * 18
SocialSec1 AS STRING * 12
Hourly1 AS DOUBLE
NormalHours1 AS SINGLE
OTimeHours1 AS SINGLE
NormalWage1 AS DOUBLE
OTimeWage1 AS DOUBLE
TotalWage1 AS DOUBLE
Name2 AS STRING * 18
SocialSec2 AS STRING * 12
Hourly2 AS DOUBLE
NormalHours2 AS SINGLE
OTimeHours2 AS SINGLE
NormalWage2 AS DOUBLE
OTimeWage2 AS DOUBLE
TotalWage2 AS DOUBLE
CombinedTotal AS DOUBLE
END TYPE
DIM Employee AS TypeX
'******************************************************************************
'---Alpha$ and Field Types govern which keys are considered 'Valid' by rsMInput
Alpha$ = " 1234567890-+.$%QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm=!@#^&*()_[]\{}|;':,/<>?`~" + CHR$(34)
'******************************************************************************
GOSUB EditEmployee 'get to work
END
'******************************************************************************
EditEmployee: 'this is what you came for
'******************************************************************************
'----- Display Screen
'******************************************************************************
LibName$ = "P-Screen": ScreenName$ = "Employee"
GOSUB DisplayScreen
'******************************************************************************
'----- Edit
FieldNum = 1 'there are 18 fields, some may be calculated
DO 'EACH LOOP: initialize RetCode, Exit$, & Format$
RetCode = 32 '32 = pad with Chr$(32) -32 = Upper Case
Exit$ = "HP;C" 'H = Up Cursor, P = Down Cursor, ; = F1 Help, C = F9 Calc
Format$ = "" 'assume no mask -- an unformatted field
Minimum$ = "" 'assume no minimum/maximum
Maximum$ = ""
ScreenName$ = "HRS/HRLY" 'Help screen for Hours/Hourly fields,
'the most frequently needed screen
ValidKeys$ = Alpha$ 'assume any character is valid
PropName = False 'assume it's NOT a proper name field
SELECT CASE FieldNum
CASE 1
Row = 8: Column = 39: Length = 16
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "## - ## - ####"
Text$ = Employee.TodaysDate
ScreenName$ = "EMPFORMT" 'Help screen for Formatted fields
CASE 2
Row = 13: Column = 1: Length = 18
PropName = True 'it IS a proper name field
Text$ = Employee.Name1
Minimum$ = "A": Maximum$ = "zzzzzzzzzzzzzzzzzzz" 'Name is REQUIRED
ScreenName$ = "EMPNAMES" 'Help screen for Formatted fields
CASE 3
Row = 13: Column = 20: Length = 12
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "###-##-####"
Text$ = Employee.SocialSec1
ScreenName$ = "EMPFORMT" 'Help screen for Formatted fields
CASE 4
Row = 13: Column = 33: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.Hourly1
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
Minimum$ = "1.00": Maximum$ = "22.99"
CASE 5
Row = 13: Column = 40: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.NormalHours1
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
CASE 6
Row = 13: Column = 47: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.OTimeHours1
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
CASE 7
Row = 15: Column = 1: Length = 18
PropName = True 'it IS a proper name field
Text$ = Employee.Name2
Minimum$ = "A": Maximum$ = "zzzzzzzzzzzzzzzzzzz" 'Name is REQUIRED
ScreenName$ = "EMPNAMES" 'Help screen for Formatted fields
CASE 8
Row = 15: Column = 20: Length = 12
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "###-##-####"
Text$ = Employee.SocialSec2
ScreenName$ = "EMPFORMT" 'Help screen for Formatted fields
CASE 9
Row = 15: Column = 33: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.Hourly2
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
Minimum$ = "1.00": Maximum$ = "22.99"
CASE 10
Row = 15: Column = 40: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.NormalHours2
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
CASE 11
Row = 15: Column = 47: Length = 5
ValidKeys$ = MID$(Alpha$, 1, 14) '0-9 Only -- plus .$-+
Format$ = "##.##"
GOSUB ConvertNumber
x# = Employee.OTimeHours2
RSET Text$ = FormatUsing$("##.##", x#)
Format$ = "" 'don't confuse rsMinput w/ a mask
CASE ELSE
END SELECT
LOCATE Row, Column
'---get color at this row/column; rsMinput takes 2 colors (Hilite, Colr to Restore)
GOSUB GetColor
'---use rsMinput or your own editing routine
CALL rsMInput(Text$, ValidKeys$, Exit$, Format$, Length, RetCode, Hilite, Colr)
IF PropName THEN 'if it's proper name, reformat/reprint
Text$ = ProperName$(Text$)
CALL rsQprint(Row, Column, Colr, Text$)
END IF
IF RetCode = -27 THEN EXIT DO 'Esc pressed, exit
GOSUB Validate 'validate against range you specified
IF Invalid AND RetCode% <> 3 THEN
BEEP
ELSE
SELECT CASE RetCode 'RetCode = position in Exit$
'1 = Up Cursor, 2 = Down Cursor, 3 = F1 Help, 4 = F9 Calc
CASE 1 'UP cursor
FieldNum = FieldNum - 1: IF FieldNum < 1 THEN FieldNum = 11
CASE 3 'F1 Help
GOSUB DisplayScreen 'display help screen. Beep = Error
CASE 4 'F9 Calc
GOSUB DoCalcs 'calculate your formulas, print results
CASE ELSE 'move forward on <cr> or DOWN cursor
FieldNum = FieldNum + 1
IF FieldNum > 11 THEN GOSUB DoCalcs: FieldNum = 1
END SELECT
END IF
LOOP UNTIL RetCode = -27 'exit on Esc
RETURN
'******************************************************************************
'******************************************************************************
GetColor: 'get colors at this Row, Column
'******************************************************************************
IF Row < 1 OR Column < 1 THEN BEEP: Colr = 7: Hilite = 112: RETURN
'avoid Illegal Function Call
Colr = SCREEN(Row, Column, -1) 'get color at this Row/Column
Fore = (Colr MOD 16): Back = (((Colr - Fore) / 16) MOD 128)
Hilite = (Fore AND 7) * 16 + Back + (Back AND 16) * 7
'reverse color for editing
RETURN
'******************************************************************************
'******************************************************************************
DisplayScreen: 'Display MAIN and HELP Screens
'******************************************************************************
IF LibName$ = "" OR ScreenName$ = "" THEN BEEP: RETURN
IF Exists(LibName$ + ".PSL") AND RTRIM$(ScreenName$) > "" THEN
REDIM Array%(1) 'initialize INTEGER screen array
CALL rsLoadScrn(Array%(), LibName$, ScreenName$, Desc$, TopRow, TopCol, BotRow, BotCol, x, ErrCode)
ELSE ErrCode = -1
END IF
IF ErrCode < 1 THEN BEEP: RETURN 'must have been an error
CALL CompRestPlus(TopRow, TopCol, BotRow, BotCol, SEG Array%(1)): ERASE Array
RETURN
'******************************************************************************
'******************************************************************************
Validate: 'Validate input against ranges you specified
'******************************************************************************
'----trap 'Invalid Number' errors, as when width of your field is too narrow
IF LEN(Text$) > 0 AND MID$(Text$, 1, 1) = "%" THEN MID$(Text$, 1, 1) = CHR$(32)
IF LEN(Text$) > 0 AND MID$(Text$, 1, 1) = "$" THEN MID$(Text$, 1, 1) = CHR$(32)
Text$ = RTRIM$(Text$)
Invalid = 0 'assume it's valid
IF Minimum$ > "" AND Maximum$ > "" THEN
SELECT CASE FieldNum 'if Text...
CASE 2, 7 'it's a Text field
IF Text$ < Minimum$ OR Text$ > Maximum$ THEN Invalid = -1
CASE ELSE 'it's a Numeric field
x# = VAL(Text$)
IF x# < VAL(Minimum$) OR x# > VAL(Maximum$) THEN Invalid = -1
END SELECT
END IF
IF Invalid THEN RETURN 'it's valid, don't assign
SELECT CASE FieldNum
CASE 1: Employee.TodaysDate = Text$
CASE 2: Employee.Name1 = Text$
CASE 3: Employee.SocialSec1 = Text$
CASE 4: Employee.Hourly1 = VAL(Text$)
CASE 5: Employee.NormalHours1 = VAL(Text$)
CASE 6: Employee.OTimeHours1 = VAL(Text$)
CASE 7: Employee.Name2 = Text$
CASE 8: Employee.SocialSec2 = Text$
CASE 9: Employee.Hourly2 = VAL(Text$)
CASE 10: Employee.NormalHours2 = VAL(Text$)
CASE 11: Employee.OTimeHours2 = VAL(Text$)
CASE ELSE
END SELECT
RETURN
'******************************************************************************
'******************************************************************************
ConvertNumber: 'set length of Text$ equal to # of valid positions in mask; inc. '.'
'******************************************************************************
IF LEN(Format$) < 1 THEN Text$ = SPACE$(Length): RETURN
NumberSpaces = 0
FOR x = 1 TO LEN(Format$)
IF INSTR("#·.", MID$(Format$, x, 1)) THEN NumberSpaces = NumberSpaces + 1
NEXT
Text$ = SPACE$(NumberSpaces)
RETURN
'******************************************************************************
'******************************************************************************
DoCalcs: 'Do calculations. Delete this if none.
'******************************************************************************
'---- Calculate: Employee.NormalWage1
Employee.NormalWage1 = Employee.Hourly1 * Employee.NormalHours1
Row = 13: Column = 53: Length = 8
x# = Employee.NormalWage1 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.OTimeWage1
Employee.OTimeWage1 = (Employee.Hourly1 * 1.5) * Employee.OTimeHours1
Row = 13: Column = 62: Length = 8
x# = Employee.OTimeWage1 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.TotalWage1
Employee.TotalWage1 = Employee.NormalWage1 + Employee.OTimeWage1
Row = 13: Column = 71: Length = 10
x# = Employee.TotalWage1 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$#####,.##", x#)
'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.NormalWage2
Employee.NormalWage2 = Employee.Hourly2 * Employee.NormalHours2
Row = 15: Column = 53: Length = 8
x# = Employee.NormalWage2 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.OTimeWage2
Employee.OTimeWage2 = (Employee.Hourly2 * 1.5) * Employee.OTimeHours2
Row = 15: Column = 62: Length = 8
x# = Employee.OTimeWage2 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.TotalWage2
Employee.TotalWage2 = Employee.NormalWage2 + Employee.OTimeWage2
Row = 15: Column = 71: Length = 10
x# = Employee.TotalWage2 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$#####,.##", x#)
'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
'---- Calculate: Employee.CombinedTotal
Employee.CombinedTotal = Employee.TotalWage1 + Employee.TotalWage2
Row = 18: Column = 68: Length = 13
x# = Employee.CombinedTotal 'FormatUsing needs DOUBLE Prec.
Temp$ = SPACE$(Length)
RSET Temp$ = FormatUsing$("$#####,.##", x#)
'RSet to allign decimals, etc.
GOSUB GetColor
CALL rsQprint(Row, Column, Colr, Temp$)
RETURN
'******************************************************************************